Shareware Grab Bag/Shareware Grab Bag.iso/001/wwiv.arc/DOS.PAS

Pascal/Delphi Source File | 1986-04-21 | 35.5 KB | 1,251 lines

program dos;


                      {*****************************}
                      {Copyright (c) 1986 Wayne Bell}
                      {*****************************}

{$C-} {$V-}
{$I COMMON.PAS}

var topheap:^byte;
    i1:str;
    ix:array[1..9] of string[79];
    donedos,dld,d1,d2,done,abort:boolean;
    c1,c2,c3:integer;
    f,f1:file of byte;
    x:byte;
    cd:str;
    s1,s2,s3:str;
    all:boolean;
    chksum:byte;
    crc:integer;
    ucrc,ymodem:boolean;
    fat,dta:string[44];
    ft:byte;
    lastvar:byte;


function tcheck(s:real; i:integer):boolean;
var r:real;
begin
  r:=timer;
  if r<s then r:=r+86400.0;
  if trunc(r-s)>i then tcheck:=false else tcheck:=true;
end;

function tchk(s:real; i:real):boolean;
var r:real;
begin
  r:=timer;
  if r<s then r:=r+86400.0;
  if (r-s)>i then tchk:=false else tchk:=true;
end;

{$I DLP1.PAS}

function okfile(fn:str):boolean;
begin
  okfile:=(pos('.LST',FN)=0) and (pos('.DAT',fn)=0) and (pos('.   ',fn)=0)
          and (pos('.FIL',fn)=0) and (pos('.TRM',fn)=0) and (pos('.LOG',fn)=0);
  if (not so) and (pos('.TXT',fn)=0) and (pos('.MSG',fn)=0)and (pos('.???',FN)=0)
    then okfile:=false;
end;

procedure printfile(fn:str);
var fil:text;
    i:str;
    abort,next:boolean;
begin
 if not hangup then begin
  assign(fil,fn);
  {$I-} reset(fil); {$I+}
  if ioresult<>0 then print('File not found.') else begin
    abort:=false;
    while not eof(fil) and (not abort) and (not hangup) do begin
      readln(fil,i);
      if i[length(i)]<>#1 then i:=i+#1;
      printa(i,abort,next);
    end;
    close(fil);
  end;
  nl;nl;
 end;
end;

procedure inli(var i:str);
var cp,rp:integer; c:char; cv,cc:integer;
begin
  rp:=1; cp:=1;
  i:='';
  if ll<>'' then begin prompt(ll); i:=ll; ll:=''; cp:=length(i)+1; rp:=cp;end;
  repeat
    getkey(c); skey(c);
    case ord(c) of
      32..126:if (cp<strlen) and (rp<thisuser.linelen) then begin
                i[cp]:=c; cp:=cp+1; rp:=rp+1; outkey(c); thisline:=thisline+c;
              end;
            127,8:if cp>1 then begin c:=chr(8);
                if i[cp-1]=chr(8) then begin prompt(' '); rp:=rp+1; end else
                 if i[cp-1]<>chr(10) then
                   begin prompt(c+' '+c); rp:=rp-1; end;
                cp:=cp-1;
              end;
           24:begin
                cp:=1; for cv:=1 to rp-1 do prompt(chr(8)+' '+chr(8));
                rp:=1;
              end;
           23:if cp>1 then repeat
                prompt(chr(8)+' '+chr(8)); rp:=rp-1; cp:=cp-1;
              until (cp=1) or (i[cp]=' ') or (i[cp]=chr(8));
           14:if (not (rbackspace in thisuser.ac)) and (rp>1) and (cp<strlen) then begin
                prompt(chr(8)); i[cp]:=chr(8); cp:=cp+1; rp:=rp-1;
              end;
           10:if (not (rbackspace in thisuser.ac)) and (cp<strlen) then begin
                prompt(c); i[cp]:=c; cp:=cp+1;
              end;
            9:begin
                cv:=5-(cp mod 5); if (cp+cv<strlen) and (rp+cv<thisuser.linelen) then
                  for cc:=1 to cv do begin
                    rp:=rp+1; prompt(' ');
                    i[cp]:=' '; cp:=cp+1;
                  end;
              end;
  end;
  until (c=chr(13)) or ((rp=thisuser.linelen) and (wordwrap in thisuser.defaults)) or hangup;
  i[0]:=chr(cp-1);
  if c<>chr(13) then begin
    cv:=cp-1;
    while (cv>0) and (i[cv]<>' ') and (i[cv]<>chr(8))do cv:=cv-1;
    if (cv>(rp div 2)) and (cv<>cp-1) then begin
      ll:=copy(i,cv+1,cp-cv); for cc:=cp-2 downto cv do prompt(chr(8));
      for cc:=cp-2 downto cv do prompt(' ');
      i[0]:=chr(cv-1);
    end;
  end;
  nl;
  if c=chr(13) then i:=i+chr(1);
end;

procedure ul;
var dok,abort:boolean; i:str;
f:file;
begin
  writeln; writeln; ft:=255;
  prompt('Send file: ');
  input(i,12);
  i:='dloads\'+i;
  assign(f,i);
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin
    close(f);
    send1(i,dok,abort);
  end else print('File not found.');
  incom:=false;
  hangup:=false;
  outcom:=false;
  writeln;
end;

procedure dl;
var dok:boolean; i:str; f:file;
begin
  writeln; writeln; ft:=255;
  prompt('Receive file: ');
  input(i,12);
  i:='dloads\'+i;
  assign(f,i);
  {$I-} reset(f); {$I+}
  if ioresult<>0 then begin
    {$I-} rewrite(f); {$I+}
    if ioresult=0 then begin
      close(f);
      dok:=true;
    end else begin
      dok:=false;
      print('Illegal filename.');
    end;
  end else begin
    close(f);
    print(#7+'File already exists.');
    prompt('Overwrite? ');
    dok:=yn;
  end;
  if dok then
    receive1(i,dok);
  hangup:=false;
  incom:=false;
  outcom:=false;
end;

procedure term;
var c:char; done,bac,eco:boolean;
    hs:byte;
    ns:array[1..9] of pnr;
    fil:file of pnr;
    lnd,i:integer;
    maxs:byte;
    rl:real;

  procedure pc(s:str);
  var i:integer;
  begin
    s:=s+chr(13);
    for i:=1 to length(s) do o1(s[i]);
  end;

  procedure cs(hs:byte);
  begin
    writeln;
    case hs of
      0:begin
          set_baud(300);
          writeln('--- 300 BAUD ---');
        end;
      1:begin
          set_baud(1200);
          writeln('=== 1200 BAUD ===');
        end;
      2:begin
          set_baud(2400);
          writeln('=-= 2400 BAUD =-=');
        end;
    end;
    writeln;
  end;

  procedure tab(x:integer);
  begin
    while wherex<x do write(' ');
  end;

  procedure dial;
  var i:integer; done:boolean; c:char; s:str;
  begin
    done:=false;
    repeat
      writeln;
      write('Dial: 1-9,M,Q,? : ');
      repeat
        read(kbd,c); c:=upcase(c);
      until c in ['1'..'9','M','Q','?'];
      writeln(c); writeln;
      if c='Q' then begin done:=true; writeln; writeln('Back in term mode.'); writeln; end;
      if c='?' then begin
        clrscr;
        writeln('N NAME                                      NUMBER         SPD');
        writeln('- ----------------------------------------  -------------  ----');
        for i:=1 to 9 do begin
          write(i,' ',ns[i].name); tab(44); write(ns[i].number); tab(60);
          case ns[i].hs of
            0:writeln(' 300');
            1:writeln('1200');
            2:writeln('2400');
          end;
        end;
      end;
      if c='M' then begin
        write('Which (1-9) ? ');
        repeat
          read(kbd,c);
        until c in ['1'..'9',#13];
        if c in ['1'..'9'] then begin
          i:=value(c);
          clrscr;
          writeln('Number: ',i);
          writeln;
          writeln('Old Name: ',ns[i].name);
          write('New Name: '); inputl(s,40);
          if s<>'' then ns[i].name:=s;
          writeln;
          writeln('Old Number: ',ns[i].number);
          write('New Number: '); input(s,14);
          if s<>'' then ns[i].number:=s;
          writeln;
          write('Old Speed: ');
          case ns[i].hs of
            0:writeln(' 300');
            1:writeln('1200');
            2:writeln('2400');
          end;
          writeln;
          writeln('0 =  300');
          if maxs>0 then writeln('1 = 1200');
          if maxs>1 then writeln('2 = 2400');
          write('New speed? '); read(kbd,c); if (c<'0') or (c>'2') then c:=#0;
          writeln(c); writeln;
          if (value(''+c)<=maxs) and (c<>#0)  then ns[i].hs:=value(''+c);
          reset(fil); seek(fil,i-1); write(fil,ns[i]); close(fil);
          c:=' ';
        end;
      end;
      if c in ['1'..'9'] then begin
        done:=true;
        i:=value(c);
        clrscr; lnd:=i;
        hs:=ns[i].hs; cs(hs);
        writeln('Dialing: ',ns[i].name);
        writeln('At     : ',ns[i].number);
        writeln;
        pc('ATDT'+ns[i].number);
      end;
    until done;
  end;

  function cdet:boolean;
  begin
    cdet:=((port[base+6] and 128)<>0)
  end;

  procedure hang;
  var rl:real;
  begin
    dump;
    term_ready(false); rl:=timer;
    while cdet and (abs(timer-rl)<1.5) do;
    term_ready(true);
  end;

  procedure redial;
  var c:char; done:boolean; try:integer; rl,rl1,rl2:real; int:integer; i,i1:str;
  begin
    clrscr; try:=0;
    hs:=ns[lnd].hs; cs(hs); rl:=timer;
    pc('ATM0Q0V0E0S7=16');
    writeln('Re-Dialing: ',ns[lnd].name);
    writeln('At        : ',ns[lnd].number);
    writeln('Try       : 0');
    writeln('Time      : 00:00');
    writeln; writeln('Hit <ESC> to abort'); done:=false;
    delay(500); dump;
    repeat
      pc('ATDT'+ns[lnd].number);
      try:=try+1;
      gotoxy(13,6); writeln(try);
      rl1:=timer; if rl1<rl then rl:=rl+24.0*3600.0;
      rl2:=abs(rl1-rl); if rl2>32000 then rl2:=32000;
      int:=trunc(rl2);
      i:=cstr(int div 60);
      if length(i)=1 then i:='0'+i;
      i1:=cstr(int mod 60);
      if length(i1)=1 then i1:='0'+i1;
      i:=i+':'+i1;
      gotoxy(13,7); writeln(i); dump;
      while (not done) and (not commpressed) do begin
        if keypressed then begin
          read(kbd,c); if c=#27 then begin done:=true; o1('A'); end;
        end;
      end;
      delay(100);
      if cdet then done:=true else dump;
    until done;
    if cdet then for try:=1 to 6 do begin
      sound(1200); delay(200); nosound; delay(100);
    end else begin
      delay(500); pc('ATM1Q0V1E1S7=30');
    end;
    gotoxy(1,14); writeln; writeln('Back in term mode...');
  end;

  procedure help;
  var x,y,c:integer;
  begin
    x:=wherex; y:=wherey;
    for c:=1 to 10 do begin
      gotoxy(42,c); write(#$b3);
    end;
    gotoxy(42,11); write(#$c0);
    while wherex<>1 do write(#$c4);
    window(43,1,80,10); clrscr;
    window(45,1,80,10); gotoxy(1,1);
    writeln('Alt-B = backspacing toggle');
    writeln('Alt-C = clear screen');
    writeln('Alt-D = dial number');
    writeln('Alt-E = echo toggle');
    writeln('Alt-H = hang up phone');
    writeln('Alt-Q = redial last number');
    writeln('Alt-S = speed toggle');
    writeln('Alt-X = exit');
    writeln('PgUp  = send file from dloads');
    write('PgDn  = receive file into dloads');
    window(1,1,80,25); gotoxy(x,y);
  end;

begin
  clrscr; lnd:=0; eco:=false;
  if maxspd=300 then maxs:=0;
  if maxspd=1200 then maxs:=1;
  if maxspd=2400 then maxs:=2;
  assign(fil,'gfiles\numbers.trm');
  reset(fil);
  for i:=1 to 9 do read(fil,ns[i]);
  close(fil);
  writeln('Press [HOME] for help');
  writeln;
  hs:=maxs; cs(hs); bac:=false;
  done:=false; mem[$40:$17]:=mem[$40:$17] or $40;
  pc('ATQ0V1E1S2=43M1S11=50');
  rl:=timer;
  repeat
    if commpressed then begin
      c:=cinkey;
      if c=chr(12) then clrscr else
        if c=chr(8) then begin
          bs;
          if bac then begin
            write(' ');
            bs;
          end;
        end
      else
        if c<>chr(0) then write(c);
      rl:=timer;
    end;
    if keypressed then begin
      read(kbd,c);
      if c=chr(27) then
        if keypressed then begin
          read(kbd,c); case ord(c) of
            48:begin bac:=not bac; writeln; writeln;
                 if bac then writeln('-Destructive-') else writeln('=Non-Destructive=');
                 writeln; writeln;
               end;
            45:done:=true;
            31:begin hs:=hs+1; if hs>maxs then hs:=0; cs(hs); end;
            32:dial;
            16:if (lnd>0) and (lnd<10) then redial;
            35:hang;
            73:ul;
            81:dl;
            71:help;
            46:clrscr;
            18:begin eco:=not eco; writeln; writeln;
                 if eco then writeln('-= ECHO ON =-') else writeln('=- ECHO OFF -=');
                 writeln; writeln;
               end;
          end;
      end else else begin o1(c); if eco then write(c); end;
      rl:=timer;
    end;
    if abs(rl-timer)>5.0*60.0 then begin
      if timer<rl then
        rl:=rl-24.0*3600.0
      else
        done:=true;
    end;
  until done;
  hang; delay(1000); pc('ATS0=0Q0V0E0M0S2=1S7=30'); delay(100); dump;
  mem[$40:$17]:=mem[$40:$17] and not $40;
end;

procedure voteprint;
var vdata:file of vdatar; vd:vdatar; vn:integer; t:text; i1,i2:integer; u:userrec;
    x:array[1..maxusers] of array[1..9] of integer;
    s1,s2:str;

begin
  assign(t,'gfiles\votes.txt');
  rewrite(t);
  writeln(t); writeln(t,'Votes as of '+dat);
  reset(uf);
  print('Beginning output to file "VOTES.TXT"');
  i1:=1;
  while (i1<filesize(uf)) do begin
    seek(uf,i1); read(uf,u);
    for i2:=1 to 9 do
      x[i1][i2]:=u.vote[i2];
    i1:=i1+1;
  end;
  close(uf);
  assign(vdata,'gfiles\voting.dat');
  reset(vdata);
  for vn:=1 to 9 do begin
    seek(vdata,vn-1); read(vdata,vd);
    if vd.numa<>0 then begin
      writeln(t); writeln(t,vd.question);
      print(vd.question);
      for i1:=1 to vd.numa do begin
        writeln(t,'   '+vd.answ[i1].ans);
        for i2:=1 to systat.users do begin
          if x[srl[i2].number][vn]=i1 then begin
            writeln(t,'      '+srl[i2].name+' #'+cstr(srl[i2].number));
          end;
        end;
      end;
    end;
  end;
  close(t);
  print('Output complete.');
end;

procedure return;
var f:file;
begin
  assign(f,'bbs.com');
  print('Returning to BBS...');
  remove_port;
  if hangup then term_ready(false);
  execute(f);
end;


procedure parse(i1:str);
var c,lp,cp:integer;
begin
  for c:=1 to 9 do ix[c]:='';
  c:=1; lp:=1; cp:=1;
  if length(i1)=1 then ix[1]:=i1;
  while cp<length(i1) do begin
    cp:=cp+1;
    if (i1[cp]=' ') or (cp=length(i1)) then begin
      if cp=length(i1) then cp:=cp+1;
      ix[c]:=copy(i1,lp,(cp-lp));
      lp:=cp+1;
      c:=c+1;
    end;
  end;
end;

function align(fn:str):str;
var f,e,t:str; c,c1:integer;
begin
  c:=pos('.',fn);
  if c=0 then begin
    f:=fn; e:='   ';
  end else begin
    f:=copy(fn,1,c-1); e:=copy(fn,c+1,3);
  end;
  while length(f)<8 do f:=f+' ';
  while length(e)<3 do e:=e+' ';
  c:=pos('*',f); if c<>0 then for c1:=c to 8 do f[c1]:='?';
  c:=pos('*',e); if c<>0 then for c1:=c to 3 do e[c1]:='?';
  align:=f+'.'+e;
end;

function vdir(var d:str):boolean;
var x:boolean;
begin
  if d[length(d)]='\' then d:=copy(d,1,length(d)-1);
  if (d='DLOADS') or (d='GFILES') then x:=true else x:=false;
  if (d='.') and so then x:=true;
  vdir:=x;
end;

procedure fix(var fn:str);
var i,i1:str; c1,c2:integer; ok:boolean;
begin
  if vdir(fn) then fn:=fn+'\';
  c1:=pos('\',fn); ok:=true;
  if c1<>0 then begin
    i:=copy(fn,1,c1-1);
    fn:=copy(fn,c1+1,15);
    if not vdir(i) then ok:=false;
  end else i:='';
  if i='' then i:=cd;
  if fn='' then fn:='*.*';
  fn:=i+'\'+align(fn);
  if (pos('.MSG',fn)=0) and (pos('.TXT',fn)=0) and (pos('?',fn)=0) and (not so) then ok:=false;
  if not ok then fn:='';
  if not okfile(fn) then fn:='';
end;

function fit(f1,f2:str):boolean;
var tf:boolean; c:integer;
begin
  tf:=true;
  for c:=1 to 12 do
    if (f1[c]<>f2[c]) and (f1[c]<>'?') then tf:=false;
  fit:=tf;
end;

overlay procedure tedit;
var cur,nex,las,b4:strptr;
    top,bottom,used:strptr;
    tline,curline,c1,c2:integer;
    fil:text;
    abort,next,done,allread:boolean;
    i1,i2:str;

  function newptr(var x:strptr):boolean;
  begin
    if used<>nil then begin
      x:=used;
      used:=used^.next;
      newptr:=true;
    end else begin
      if (maxavail<0) or (maxavail>100) then begin
        new(x);
        newptr:=true;
      end else newptr:=false;
    end;
  end;

  procedure oldptr(var x:strptr);
  begin
    x^.next:=used;
    used:=x;
  end;

  procedure pline(cl:integer; var cp:strptr; var abort:boolean);
  var next:boolean; i:str;
  begin
    if not abort then begin
      if cp=nil then i:='      [END]' else begin
        i:=cstr(cl);
        while length(i)<4 do i:=' '+i;
        i:=i+': '+cp^.i;
      end;
      printacr(i,abort,next);
    end;
  end;

  procedure pl;
  var abort:boolean;
  begin
    abort:=false;
    pline(curline,cur,abort);
  end;

begin
  nl; allread:=true;
  used:=nil;
  top:=nil;
  bottom:=nil;
  fix(ix[2]);
  if (pos('.MSG',ix[2])=0) and (pos('.TXT',ix[2])=0) then ix[2]:='';
  if ix[2]='' then print('Illegal filename.') else begin
    assign(fil,ix[2]); abort:=false;
    {$I-} reset(fil); {$I+}
    tline:=0;
    new(cur);
    cur^.last:=nil;
    cur^.i:='';
    if ioresult<>0 then begin
      {$I-} rewrite(fil); {$I+}
      if ioresult<>0 then begin
        print('Illegal filename.');
        abort:=true;
      end else begin
        close(fil); erase(fil);
        print('New file.');
        tline:=0;
        cur:=nil; top:=cur; bottom:=cur;
      end;
    end else begin
      abort:=not newptr(nex);
      top:=nex;
      print('Loading...');
      while (not eof(fil)) and (not abort) do begin
        tline:=tline+1;
        cur^.next:=nex;
        nex^.last:=cur;
        cur:=nex;
        readln(fil,i1);
        cur^.i:=i1;
        abort:=not newptr(nex);
      end;
      close(fil);
      cur^.next:=nil;
      if tline=0 then begin cur:=nil; top:=nil; end;
      bottom:=cur;
      if abort then begin print('Not all of file read.'); allread:=false; end;
      abort:=false;
    end;
    if not abort then begin
      print('Total lines: '+cstr(tline));
      cur:=top;
      if top<>nil then top^.last:=nil;
      curline:=1;
      done:=false;
      pl;
      repeat
        prompt(':');
        input(i1,10);
        if i1='' then i1:='+';
        if value(i1)>0 then begin
          c1:=value(i1);
          if (c1>0) and (c1<=tline) then begin
            while c1<>curline do
              if c1<curline then begin
                if cur=nil then begin
                  cur:=bottom;
                  curline:=tline;
                end else begin
                  curline:=curline-1;
                  cur:=cur^.last;
                end;
              end else begin
                curline:=curline+1;
                cur:=cur^.next;
              end;
            pl;
          end;
        end else case i1[1] of
          '+':if cur<>nil then begin
                c1:=value(copy(i1,2,9));
                if c1=0 then c1:=1;
                while (cur<>nil) and (c1>0) do begin
                  cur:=cur^.next;
                  curline:=curline+1;
                  c1:=c1-1;
                end;
                pl;
              end;
          '?':begin
                print('P:rint line      L:ist');
                print('-:back line      +:forward line');
                print('T:op             B:ottom');
                print('I:nsert lines    D:elete line');
                print('R:eplace line    C:lear workspace');
                print('Q:uit            S:ave');
              end;
          '-':begin
                c1:=value(copy(i1,2,9));
                if c1=0 then c1:=1;
                if cur=nil then begin
                  cur:=bottom;
                  curline:=tline;
                  c1:=c1-1;
                end;
                if cur<>nil then
                  if cur^.last<>nil then begin
                    while (cur^.last<>nil) and (c1>0) do begin
                      cur:=cur^.last;
                      curline:=curline-1;
                      c1:=c1-1;
                    end;
                    pl;
                  end;
              end;
          'C':begin
                prompt('Clear workspace? ');
                if yn then begin
                  tline:=0; curline:=1;
                  cur:=nil; top:=nil; bottom:=nil;
                  release(topheap);
                end;
              end;
          'P':pl;
          'D':begin
                c1:=value(copy(i1,2,9));
                if c1=0 then c1:=1;
                while (cur<>nil) and (c1>0) do begin
                  las:=cur^.last;
                  nex:=cur^.next;
                  if las<>nil then las^.next:=nex;
                  if nex<>nil then nex^.last:=las;
                  oldptr(cur);
                  if bottom=cur then bottom:=las;
                  if top=cur then top:=nex;
                  cur:=nex;
                  tline:=tline-1;
                  c1:=c1-1;
                end;
                pl;
              end;
          'R':if cur<>nil then begin
                pl;
                i2:=cstr(curline); while length(i2)<>4 do i2:=' '+i2;
                i2:=i2+': '; prompt(i2);
                inli(i1);
                cur^.i:=i1;
              end;
          'I':begin
                abort:=false; ll:='';
                print('Enter "." on a seperate line to exit insert mode.');
                i1:=''; thisuser.linelen:=thisuser.linelen-6;
                while (not abort) and (i1<>'.') and (i1<>'.'+#1) do begin
                  i2:=cstr(curline); while length(i2)<>4 do i2:=' '+i2;
                  i2:=i2+': '; prompt(i2);
                  inli(i1);
                  if (i1<>'.') and (i1<>'.'+#1) then begin
                    abort:=not newptr(nex);
                    if not abort then begin
                      nex^.i:=i1;
                      if (top=cur) then
                        if cur=nil then begin
                          nex^.last:=nil;
                          nex^.next:=nil;
                          top:=nex;
                          bottom:=nex;
                        end else begin
                          nex^.next:=cur;
                          cur^.last:=nex;
                          top:=nex;
                        end
                      else begin
                        if cur=nil then begin
                          bottom^.next:=nex;
                          nex^.last:=bottom;
                          nex^.next:=nil;
                          bottom:=nex;
                        end else begin
                          las:=cur^.last;
                          nex^.last:=las;
                          nex^.next:=cur;
                          cur^.last:=nex;
                          las^.next:=nex;
                        end;
                      end;
                      curline:=curline+1;
                      tline:=tline+1;
                    end else print('No room left.');
                  end;
                end;
                thisuser.linelen:=thisuser.linelen+6;
              end;
          'T':begin
                cur:=top;
                curline:=1;
                pl;
              end;
          'B':begin
                cur:=nil;
                curline:=tline+1;
                pl;
              end;
          'L':begin
                abort:=false;
                nex:=cur;
                c1:=curline;
                while (not abort) and (nex<>nil) do begin
                  pline(c1,nex,abort);
                  nex:=nex^.next;
                  c1:=c1+1;
                end;
              end;
          'Q':done:=true;
          'S':begin
                if not allread then begin
                  prompt('Not all of file read.  Save anyway? ');
                  allread:=yn;
                end;
                if allread then begin
                  done:=true;
                  writeln('Saving...');
                  rewrite(fil);
                  cur:=top;
                  while cur<>nil do begin
                    writeln(fil,cur^.i);
                    cur:=cur^.next;
                  end;
                  close(fil);
                end;
              end;
        end;
      until done;
    end;
  end;
  release(topheap);
end;

overlay procedure gfileedit;
var b,b1:gft; f:file of gft; i:str; t,c:integer; ok,exit:boolean;
    gftit:array[1..150] of record tit:string[80]; arn:integer; gfile:boolean;end;
    nums,lgftn,numgft:integer;
    gfs:array[0..100] of record tit:string[80]; arn:integer; end;
    c1,c2,c3,c4:integer; s1,s2,s3,s4:str; ch:char;

  procedure gettit(n:integer);
  var r:integer; b:gft;
  begin
    numgft:=0;
    r:=n+1;
    if r<=t then begin
      seek(f,r); read(f,b);
      while (r<=t) and (b.filen[1]<>#1) do begin
        begin
          numgft:=numgft+1;
          gftit[numgft].tit:=b.title;
          gftit[numgft].arn:=r;
          gftit[numgft].gfile:=true;
        end;
        r:=r+1;
        if (r<=t) then begin seek(f,r); read(f,b);end;
      end;
    end;
  end;

  procedure getsec;
  var r:integer; b:gft;
  begin
    nums:=0;
    gfs[0].tit:='[ Main Section ]';
    gfs[0].arn:=0;
    for r:=1 to t do begin
      seek(f,r); read(f,b);
      if b.filen[1]=#1 then begin
        nums:=nums+1;
        gfs[nums].tit:='[ '+b.title+' ]';
        gfs[nums].arn:=r;
      end;
    end;
    gfs[nums+1].arn:=t+1;
  end;

  procedure listsec;
  var r:integer; i:str; abort,next:boolean;
  begin
    r:=0; abort:=false; nl; nl;
    while (r<=nums) and (not abort) do begin
      i:=cstr(r)+': '+gfs[r].tit;
      r:=r+1;
      printacr(i,abort,next);
    end;
  end;

  procedure lgft;
  var abort,next:boolean; c:integer; b:gft;
  begin
    nl; nl;
    if numgft=0 then print('No G-files.') else begin
      abort:=false; next:=false; c:=1;
      while (c<=numgft) and (not abort) do begin
        seek(f,gftit[c].arn); read(f,b);
        i:=cstr(c)+': '; if length(i)=3 then i:=' '+i;
        i:=i+b.filen;
        while length(i)<18 do i:=i+' ';
        i:=i+cstr(b.num);
        while length(i)<24 do i:=i+' ';
        i:=i+b.title;
        printacr(i,abort,next);
        c:=c+1;
      end;
    end;
  end;

begin
  nl;assign(f,'gfiles\gfiles.dat'); {$I-} reset(f); {$I+}
  if ioresult<>0 then begin
    rewrite(f); b.num:=0; write(f,b);
  end;
  seek(f,0); read(f,b); t:=b.num; exit:=false;
    repeat
      nl; nl;prompt('Gfile Edit: Q,I,D,S,? : ');
      onek(ch,'QIDS?'); getsec;
      case ch of
        'Q':exit:=true;
        '?':begin
              print('Q:uit from gfile edit   ?:this list');
              print('I:nsert G-file          D:delete G-file');
              print('S:ection modification');
            end;
        'S':begin
              prompt('I:nsert, D:elete, Q:uit ? '); onek(ch,'QID');
              case ch of
                'I':begin
                      listsec;
                      prompt('Before which section (1-'+cstr(nums+1)+') : '); input(s1,2);
                      c1:=value(s1);
                      if (c1>0) and (c1<=(nums+1)) then begin
                        if c1<=nums then
                          c1:=gfs[c1].arn
                        else
                          c1:=t+1;
                        prompt('Section title? '); inputl(b.title,40);
                        prompt('SL requirement? '); input(s1,3);
                        b.num:=value(s1); b.filen:=#1#0#0#0#0#0;
                        for c3:=t downto c1 do begin
                          seek(f,c3); read(f,b1); seek(f,c3+1); write(f,b1);
                        end;
                        seek(f,c1); write(f,b); t:=t+1;
                        b.num:=t; seek(f,0); write(f,b);
                      end else print('Illegal section number.');
                    end;
                'D':begin
                      listsec;
                      prompt('Delete which section (1-'+cstr(nums)+') : '); input(s1,2);
                      c1:=value(s1);
                      if ((c1>0) and (c1<=nums)) then begin
                        c2:=gfs[c1].arn;
                        if c1=nums then c3:=t+1 else c3:=gfs[c1+1].arn;
                        c1:=(c3-c2);
                        for c4:=c3 to t do begin
                          seek(f,c4); read(f,b); seek(f,c4-c1); write(f,b);
                        end;
                        seek(f,0); t:=t-c1; b.num:=t; write(f,b);
                      end;
                    end;
              end;
            end;
        'D':begin
              listsec;
              prompt('Which section (0-'+cstr(nums)+') : '); input(s1,2);
              c1:=value(s1);
              if (s1='0') or ((c1>0) and (c1<=nums)) then begin
                gettit(gfs[c1].arn);
                lgft;
                prompt('Delete which (1-'+cstr(numgft)+') :');
                input(s1,3);
                c1:=value(s1);
                if (c1>0) and (c1<=(numgft)) then begin
                  c1:=gftit[c1].arn;
                  for c2:=c1+1 to t do begin
                    seek(f,c2); read(f,b); seek(f,c2-1); write(f,b);
                  end;
                  seek(f,0); read(f,b); b.num:=b.num-1;
                  seek(f,0); write(f,b); t:=t-1;
                end;
              end;
            end;
        'I':begin
              listsec;
              prompt('Which section (0-'+cstr(nums)+') : '); input(s1,2);
              c1:=value(s1);
              if (s1='0') or ((c1>0) and (c1<=nums)) then begin
                gettit(gfs[c1].arn);
                lgft; c4:=c1;
                prompt('Insert before which (1-'+cstr(numgft+1)+') :');
                input(s1,3);
                c1:=value(s1);
                if (c1>0) and (c1<=(numgft+1)) then begin
                  if c1<=numgft then
                    c2:=gftit[c1].arn
                  else
                    c2:=gfs[c4+1].arn;
                  prompt('Enter filename of new G-file : ');
                  input(b.filen,12); if (pos('.TXT',b.filen)=0) and
                  (pos('.MSG',b.filen)=0) then b.filen:='';
                  assign(f1,'gfiles\'+b.filen); {$I-} reset(f1); {$I+}
                  ok:=false; if ioresult=0 then begin close(f1); ok:=true; end;
                  if b.filen='' then ok:=false;
                  if ok then begin
                    nl; prompt('Enter title : '); inputl(b.title,40);
                    prompt('Enter SL : ');
                    input(i,3); b.num:=value(i);
                    for c3:=t downto c2 do begin
                      seek(f,c3); read(f,b1); seek(f,c3+1); write(f,b1);
                    end;
                    seek(f,c2); write(f,b); t:=t+1;
                    seek(f,0); read(f,b); b.num:=b.num+1; seek(f,0); write(f,b);
                  end else print('Illegal filename.');
                end;
              end;
            end;
      end;
    until exit or hangup;
  close(f);
  nl;nl;
end;


function ffile(x:str):str;
var r:regs; x1:str;
begin
  x:=align(x); x1:=copy(x,1,8)+copy(x,10,3);
  fat:= #255#0#0#0#0#0#0#0+x1+#0#0#0#0+'                     ';
  dta := #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0+
               #0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0#0;
  r.ds := seg(dta);
  r.dx := ofs(dta)+1;
  r.ax := $1a00;
  msdos(r);
  r.ds := seg(fat);
  r.dx := ofs(fat)+1;
  r.ax := $1100;
  msdos(r);
  if r.ax=$1100 then x1:=copy(dta,9,8)+'.'+copy(dta,17,3) else x1:='';
  ffile:=x1;
end;

function nfile:str;
var x1:str; r:regs;
begin
  r.ax:=$1200;
  r.ds := seg(fat);
  r.dx := ofs(fat)+1;
  msdos(r);
  if r.ax=$1200 then x1:=copy(dta,9,8)+'.'+copy(dta,17,3) else x1:='';
  nfile:=x1;
end;

procedure dir(cd,x:str; all:boolean);
var
  abort,next:boolean;
  x1:str;
begin
  if cd<>'.' then chdir(cd);
  x1:=ffile(x);
  nl; abort:=false;
  while (x1<>'') and not abort do begin
    if ((copy(x1,10,3)='MSG') or (copy(x1,10,3)='TXT') or all) and okfile(x1) then
      printacr(x1,abort,next);
    x1:=nfile;
  end;
  nl; printacr('  Free space = '+cstr(freek)+'k',abort,next);
  if cd<>'.' then chdir('..');
end;

procedure copyfile(srcname,destname:str);
var buffer: array[1..16384] of byte;
    nrec:integer;
    src, dest: file;
begin
  assign(src,srcname); reset(src,1);
  if trunc(longfilesize(src)/1024.0)+1>=freek then
    print('Disk full.')
  else begin
    assign(dest,destname); rewrite(dest,1);
    nl; print('Copying...');
    repeat
      blockread(src,buffer,16384,nrec);
      blockwrite(dest,buffer,nrec);
    until nrec<16384;
    close(dest);
  end;
  close(src);
end;


procedure ren;
begin
  fix(ix[2]); fix(ix[3]); abort:=false; nl;
  if (ix[2]='') or (ix[3]='') then begin abort:=true; print('Illegal filename.'); end;
  if not abort then begin
    assign(f,ix[2]); {$I-} reset(f); {$I+}
    if ioresult=0 then begin
      close(f); assign(f,ix[3]); {$I-} reset(f); {$I+}
      if ioresult<>0 then begin
        {$I-} rewrite(f); {$I+}
        if ioresult=0 then begin
          close(f); erase(f); assign(f,ix[2]); rename(f,ix[3]);
          print('Renamed.');
        end else print('Illegal filename.');
      end else begin close(f); print('Filename already in use.'); end;
    end else print('File not found.');
  end;
end;

procedure delfil;
begin
  nl;
  fix(ix[2]);
  if (not so) and (pos('.TXT',ix[2])=0) then begin
    ix[2]:='';
  end;
  if ix[2]<>'' then begin
    assign(f,ix[2]);
    {$I-} erase(f); {$I+}
    if ioresult=0 then print('Deleted.') else print('File not found.');
  end else print('Illegal filename.');
end;

procedure copyf;
begin
  fix(ix[2]); fix(ix[3]); nl;
  if (pos('????????.???',ix[3])<>0) then begin
    s1:=copy(ix[3],1,pos('\',ix[3])-1);
    s2:=copy(ix[2],pos('\',ix[2])+1,12);
    ix[3]:=s1+'\'+s2;
  end;
  if (ix[2]='') or (ix[3]='') then print('Illegal filename.') else begin
    assign(f,ix[2]); assign(f1,ix[3]);
    {$I-} reset(f); {$I+}
    if ioresult<>0 then print('File not found.') else begin
      close(f);
      {$I-} reset(f1); {$I+}
      if ioresult=0 then begin
        print('File already exists.');
        close(f1);
      end else begin
        {$I-} rewrite(f1); {$I+}
        if ioresult<>0 then begin close(f); print('Illegal filename.'); end else begin
          close(f1);
          copyfile(ix[2],ix[3]);
        end;
      end;
    end;
  end;
end;

procedure dirf;
begin
  all:=false;
  if not (vdir(ix[2]) or (ix[2]='')) and so then all:=true;
  fix(ix[2]);
  c1:=pos('\',ix[2]);
  s1:=copy(ix[2],1,c1-1);
  s2:=copy(ix[2],c1+1,12);
  if s1='' then s1:=cd;
  nl; dir(s1,s2,all);
end;

procedure typef;
begin
  nl;
  fix(ix[2]);
  if ix[2]<>'' then printfile(ix[2]) else print('Illegal filename.');
end;

procedure loadhelp;
var f:file; ch1:char; a,b,c:integer;
begin
  assign(f,'gfiles\help.msg');
  for ch1:='0' to '^' do helpi[ch1]:=0;
  {$I-} reset(f,1); {$I+}
  if ioresult=0 then begin
    blockread(f,help[1],25000,a);
    close(f);
    b:=1;
    while (b<a) do begin
      if help[b]='|' then begin
        ch1:=help[b+1];
        if ch1 in ['0'..'^'] then begin
          c:=b;
          while (help[c]<>#10) and (abs(c-b)<80) do c:=c+1;
          c:=c+1;
          if c<a then helpi[ch1]:=c;
        end;
      end;
      b:=b+1;
    end;
    help[a+1]:='|';
    print('Help file loaded.');
  end else print('No help file present.');
  nl;
end;


procedure dosfc;
begin
  nl; prompt(cd+': ');
  input(i1,35); parse(i1);
  if ix[1]='?' then begin
    nl; nl; printfile('gfiles\dosmnu.msg');
  end;
  if ix[1]='EDIT' then tedit;
  if ix[1]='VOTEPRINT' then voteprint;
  if ix[1]='LOADHELP' then loadhelp;
  if ix[1]='GFILE' then gfileedit;
  if ix[1]='QUIT' then donedos:=true;
  if ix[1]='DEL' then delfil;
  if ix[1]='TYPE' then typef;
  if ix[1]='REN' then ren;
  if ix[1]='DIR' then dirf;
  if ix[1]='CD' then if vdir(ix[2]) then cd:=ix[2];
  if ix[1]='COPY' then copyf;
  if ix[1]='CLS' then cls;
end;

begin
  iport; cd:='GFILES';
  topheap:=ptr(seg(lastvar),ofs(lastvar));
  release(topheap);
  case upcase(cmd) of
    'D':begin
          donedos:=false;
          print('Now in Mini-DOS.  "?" for help');
          print('Only .TXT or .MSG files can be accessed.'); nl; nl;
          while (not hangup) and (not donedos) do
            dosfc;
        end;
    'T':term;
    'G':gfileedit;
    'E':begin
          prompt('Filename: ');
          input(ix[2],12);
          tedit;
        end;
  end;
  return;
end.